home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE15 / EXECFILE / EXECFILE.ZIP / EXECFI32.ZIP / EXECFILE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-07-14  |  6.3 KB  |  186 lines
  1. unit Execfile;
  2.  
  3. {Version 2.0 Update 7/14/96}
  4.  
  5. interface
  6.  
  7. uses
  8.   SysUtils, WinTypes, WinProcs, Messages,
  9.   Classes, Graphics, Controls, Forms,
  10.   Dialogs;
  11.  
  12. type
  13.   TWindowStyle = ( wsNorm, wsMinimize, wsMaximize, wsHide,
  14.   wsMinNoActivate, wsShowNoActivate );
  15.   TWaitStyle = ( wRegular, wSuspend );
  16.   TPriorityClass = ( pcNormal, pcIdle, pcHigh, pcRealTime );
  17.   InString = String[255];
  18.   TExecFile = class(TComponent)
  19.   private
  20.    FStopWaiting: Boolean;
  21.    FMsg: TMsg;
  22.    FAss: Boolean;
  23.    FInstanceID: Integer;
  24.    FPriorityClass: TPriorityClass;
  25.    FPriorityValue: Integer;
  26.    FError: Integer;
  27.    FExitCode: Integer;
  28.    FIsWaiting: Boolean;
  29.    FWait: Boolean;
  30.    FWaitStyle: TWaitStyle; {Wait method}
  31.    FOnFail: TNotifyEvent;
  32.    FCommandLine: InString;   {Command Line of Executable File}
  33.    FRCommandLine: InString;
  34.    FFParams: InString; {Parameters to send to Executable File}
  35.    FAssFName: String; {Name of associated executable}
  36.    FAssFDir: String; {Path of associated executable}
  37.    FWindowStyle: TWindowStyle; {Window style for Executable File}
  38.    StartUpInfo: TStartUpInfo;
  39.    ProcessInfo: TProcessInformation;
  40.   protected
  41.    procedure SetWindowStyle( Value: TWindowStyle );
  42.    procedure SetWaitStyle ( Value: TWaitStyle );
  43.    procedure SetPriorityClass ( Value: TPriorityClass );
  44.   public
  45.    function Execute: Boolean;
  46.    function Terminate: Boolean;
  47.    function IsWaiting: Boolean;
  48.    function StopWaiting: Boolean;
  49.    function ErrorCode: LongInt;
  50.   published
  51.    property Associate: Boolean read FAss write FAss;
  52.    property CommandLine: InString read FCommandLine write FCommandLine;
  53.    property Parameters: InString read FFParams write FFParams;
  54.    property Priority: TPriorityClass read FPriorityClass write SetPriorityClass default pcNormal;
  55.    property Wait: Boolean read FWait write FWait;
  56.    property WaitStyle: TWaitStyle read FWaitStyle write SetWaitStyle default wRegular;
  57.    property WindowStyle: TWindowStyle read FWindowStyle write SetWindowStyle default wsNorm;
  58.    property OnFail: TNotifyEvent read FOnFail write FOnFail;
  59.   end;
  60.  
  61. procedure Register;
  62.  
  63. implementation
  64.  
  65. uses ShellAPI;
  66.  
  67.  
  68. procedure TExecFile.SetWindowStyle(Value : TWindowStyle);
  69. begin FWindowStyle := Value;
  70. end;
  71.  
  72. procedure TExecFile.SetWaitStyle(Value : TWaitStyle);
  73. begin FWaitStyle := Value;
  74. end;
  75.  
  76. procedure TExecFile.SetPriorityClass(Value : TPriorityClass);
  77. begin FPriorityClass := Value;
  78. end;
  79.  
  80. procedure Register;
  81. begin RegisterComponents('Samples', [TExecFile]);
  82. end;
  83.  
  84. function TExecFile.Execute: Boolean;
  85. var zCommandLine: array[0..512] of Char;
  86. zFAssFName: array[0..255] of Char;
  87. zFAssFDir: array[0..255] of Char;
  88. zFAssFDoc: array[0..255] of Char;
  89. FSuccess: Boolean;
  90. begin
  91.  
  92. FillChar(StartupInfo,Sizeof(StartupInfo),#0);
  93. StartupInfo.cb := Sizeof(StartupInfo);
  94. StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  95.  
  96. If FWindowStyle = wsNorm then StartupInfo.wShowWindow := SW_SHOWNORMAL;
  97. If FWindowStyle = wsMinimize then StartupInfo.wShowWindow := SW_SHOWMINIMIZED;
  98. If FWindowStyle = wsMaximize then StartupInfo.wShowWindow := SW_SHOWMAXIMIZED;
  99. If FWindowStyle = wsHide then StartupInfo.wShowWindow := SW_HIDE;
  100. If FWindowStyle = wsMinNoActivate then StartupInfo.wShowWindow := SW_SHOWMINNOACTIVE;
  101. If FWindowStyle = wsShowNoActivate then StartupInfo.wShowWindow := SW_SHOWNA;
  102.  
  103. If FPriorityClass = pcHigh then FPriorityValue := HIGH_PRIORITY_CLASS;
  104. If FPriorityClass = pcIdle then FPriorityValue := IDLE_PRIORITY_CLASS;
  105. If FPriorityClass = pcNormal then FPriorityValue := NORMAL_PRIORITY_CLASS;
  106. If FPriorityClass = pcRealTime then FPriorityValue := REALTIME_PRIORITY_CLASS;
  107.  
  108. StrPCopy(zCommandLine,FCommandLine+' '+FFParams);
  109.  
  110. FSuccess := CreateProcess(nil,
  111.       zCommandLine,           { pointer to command line string }
  112.       nil,                    { pointer to process security attributes }
  113.       nil,                    { pointer to thread security attributes }
  114.       false,                  { handle inheritance flag }
  115.       CREATE_NEW_CONSOLE or   { creation flags }
  116.       FPriorityValue,
  117.       nil,                    { pointer to new environment block }
  118.       nil,                    { pointer to current directory name }
  119.       StartupInfo,            { pointer to STARTUPINFO }
  120.       ProcessInfo);
  121.  
  122. If not FSuccess then begin
  123.  If FAss then begin StrPCopy(zFAssFDoc,FCommandLine);
  124.   If findExecutable(zFAssFDoc,zFAssFDir,zFAssFName)<32 then begin
  125.    FError := GetLastError(); If Assigned(FOnFail) then FOnFail(Self);
  126.    Result := False; exit;
  127.   end else begin FAssFName := zFAssFName;
  128.    StrPCopy(zCommandLine,FAssFName+' '+FCommandLine+' '+FFParams);
  129.    FSuccess := CreateProcess(nil,
  130.       zCommandLine,           { pointer to command line string }
  131.       nil,                    { pointer to process security attributes }
  132.       nil,                    { pointer to thread security attributes }
  133.       false,                  { handle inheritance flag }
  134.       CREATE_NEW_CONSOLE or   { creation flags }
  135.       FPriorityValue,
  136.       nil,                    { pointer to new environment block }
  137.       nil,                    { pointer to current directory name }
  138.       StartupInfo,            { pointer to STARTUPINFO }
  139.       ProcessInfo);
  140.   end
  141.  end;
  142. end;
  143.  
  144. If FSuccess then begin
  145.   If FWait then begin FIsWaiting := True; FStopWaiting := False;
  146.    If FWaitStyle = wRegular then begin
  147.     repeat
  148.      While PeekMessage(FMsg,0,0,0,PM_REMOVE) do begin
  149.      If FMsg.Message = WM_QUIT then halt(FMsg.wParam);
  150.      TranslateMessage(FMsg); DispatchMessage(FMsg); end;
  151.      If WaitforSingleObject(ProcessInfo.hProcess,0)<>WAIT_TIMEOUT then begin
  152.      FStopWaiting := True; Application.ProcessMessages; end;
  153.      Until FStopWaiting; end
  154.    else begin
  155.    WaitForSingleObject(ProcessInfo.hProcess,INFINITE); end;
  156.   FIsWaiting := False; Result:= True; end;
  157. end else begin
  158.  FError := GetLastError(); If Assigned(FOnFail) then FOnFail(Self);
  159.  Result := False; end;
  160.  
  161. end;
  162.  
  163. function TExecFile.Terminate: Boolean;
  164. begin
  165. GetExitCodeProcess(ProcessInfo.hProcess,FExitCode);
  166. If TerminateProcess(ProcessInfo.hProcess,FExitCode) then Result := True;
  167. end;
  168.  
  169. function TExecFile.IsWaiting: Boolean;
  170. begin
  171. Result := FIsWaiting;
  172. end;
  173.  
  174. function TExecFile.StopWaiting: Boolean;
  175. begin
  176. FStopWaiting := True;
  177. Result := True;
  178. end;
  179.  
  180. function TExecFile.ErrorCode: LongInt;
  181. begin
  182. Result := FError;
  183. end;
  184.  
  185. end.
  186.